home *** CD-ROM | disk | FTP | other *** search
/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48hor1 / calendar.src < prev    next >
Text File  |  1990-10-20  |  3KB  |  106 lines
  1. %%HP: T(3)A(D)F(.);
  2. @ by Kevin Jessup.
  3. DIR
  4.   CURR
  5.     \<< DATE CAL
  6.     \>>
  7.   \<-Y
  8.     \<< 'year' 1 STO- GENCAL
  9.     \>>
  10.   Y\->
  11.     \<< 'year' 1 STO+ GENCAL
  12.     \>>
  13.   \<-M
  14.     \<<
  15.       IF month 1 - DUP 1 <
  16.       THEN DROP 12 'year' 1 STO-
  17.       END 'month' STO GENCAL
  18.     \>>
  19.   M\->
  20.     \<<
  21.       IF month 1 + DUP 12 >
  22.       THEN DROP 1 'year' 1 STO+
  23.       END 'month' STO GENCAL
  24.     \>>
  25.   PCAL
  26.     \<< PICT RCL PR1 DROP
  27.     \>>
  28.   CAL
  29.     \<< EXPDT JFIX 'year' STO 'month' STO 'day' STO GENCAL
  30.     \>>
  31.   DOW
  32.     \<< DATE SDOW
  33.     \>>
  34.   SDOW
  35.     \<< 0 TSTR 1 3 SUB
  36.     \>>
  37.   RDOW
  38.     \<< SDOW DOWL SWAP POS 1 -
  39.     \>>
  40.   LPYR
  41.     \<< \-> y
  42.       \<< y 4 MOD NOT y 100 MOD AND y 400 MOD NOT OR
  43.       \>>
  44.     \>>
  45.   ALMDATE?
  46.     \<<
  47.       IF DUP FINDALARM DUP
  48.       THEN RCLALARM 1 GET ==
  49.       ELSE DROP 0
  50.       END
  51.     \>>
  52.   MOY { "JANUARY" "FEBRUARY" "MARCH" "APRIL" "MAY" "JUNE" "JULY"
  53.       "AUGUST" "SEPTEMBER" "OCTOBER" "NOVEMBER" "DECEMBER" }
  54.   DIM { 31 28 31 30 31 30 31 31 30 31 30 31 }
  55.   DOWL { "SUN" "MON" "TUE" "WED" "THU" "FRI" "SAT" }
  56.   GENCAL
  57.     \<< { # 0h # 0h } PVIEW MONTHBOX MOY month GET " " + year \->STR + 1
  58.       \->GROB DUP SIZE DROP # 83h SWAP - # 2h / # 2h 2 \->LIST PICT SWAP
  59.       ROT REPL FILLDAYS 7 FREEZE
  60.     \>>
  61.   FILLDAYS
  62.     \<< 1 month year JFIX CPSDT RDOW 0 1 DIM month GET
  63.       IF month 2 == year LPYR AND
  64.       THEN 1 +
  65.       END
  66.       FOR d PICT 3 PICK R\->B # 12h * # 6h + 3 PICK R\->B # 8h * # 10h + 2
  67.         \->LIST d \->STR d month year JFIX CPSDT
  68.         IF ALMDATE?
  69.         THEN 1 CHR +
  70.         END 1 \->GROB REPL SWAP
  71.         IF 1 + DUP 6 >
  72.         THEN DROP 0 SWAP 1 + SWAP
  73.         END SWAP
  74.       NEXT DROP2
  75.     \>>
  76.   MONTHBOX
  77.     \<< # 83h # 3Eh BLANK PICT STO
  78.       { # 2h # 0h } { # 80h # 0h } LINE
  79.       { # 2h # 0h } { # 2h # 3Dh } LINE
  80.       { # 80h # 0h } { # 80h # 3Dh } LINE # Eh 1 7
  81.       START # 2h OVER 2 \->LIST OVER # 80h SWAP 2 \->LIST LINE # 8h +
  82.       NEXT DROP # 14h 1 6
  83.       START DUP # Fh 2 \->LIST OVER # 3Eh 2 \->LIST LINE # 12h +
  84.       NEXT DROP # 5h 1 7
  85.       FOR i DUP # 8h 2 \->LIST DOWL i GET 1 3 SUB 1 \->GROB PICT 3 ROLLD REPL
  86.         # 12h +
  87.       NEXT DROP
  88.     \>>
  89.   CPSDT
  90.     \<< 10000 / SWAP IP + 100 / SWAP IP +
  91.     \>>
  92.   EXPDT
  93.     \<< DUP IP SWAP FP 100 * DUP IP SWAP FP 10000 *
  94.     \>>
  95.   JFIX
  96.     \<<
  97.       IF -42 FC?
  98.       THEN 3 ROLLD SWAP 3 ROLL
  99.       END
  100.     \>>
  101.   day 19
  102.   year 1990
  103.   month 10
  104.   PPAR { (-6.5,-3.1) (6.5,3.2) X 0 (0,0) FUNCTION Y }
  105. END
  106.